home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / thomas / thomas.lha / Thomas / Thomas-1.1 / src / runtime-methods.scm < prev    next >
Text File  |  1992-09-19  |  26KB  |  841 lines
  1. ;*              Copyright 1992 Digital Equipment Corporation
  2. ;*                         All Rights Reserved
  3. ;*
  4. ;* Permission to use, copy, and modify this software and its documentation is
  5. ;* hereby granted only under the following terms and conditions.  Both the
  6. ;* above copyright notice and this permission notice must appear in all copies
  7. ;* of the software, derivative works or modified versions, and any portions
  8. ;* thereof, and both notices must appear in supporting documentation.
  9. ;*
  10. ;* Users of this software agree to the terms and conditions set forth herein,
  11. ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
  12. ;* right and license under any changes, enhancements or extensions made to the
  13. ;* core functions of the software, including but not limited to those affording
  14. ;* compatibility with other hardware or software environments, but excluding
  15. ;* applications which incorporate this software.  Users further agree to use
  16. ;* their best efforts to return to Digital any such changes, enhancements or
  17. ;* extensions that they make and inform Digital of noteworthy uses of this
  18. ;* software.  Correspondence should be provided to Digital at:
  19. ;*
  20. ;*            Director, Cambridge Research Lab
  21. ;*            Digital Equipment Corp
  22. ;*            One Kendall Square, Bldg 700
  23. ;*            Cambridge MA 02139
  24. ;*
  25. ;* This software may be distributed (but not offered for sale or transferred
  26. ;* for compensation) to third parties, provided such third parties agree to
  27. ;* abide by the terms and conditions of this notice.
  28. ;*
  29. ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
  30. ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
  31. ;* MERCHANTABILITY AND FITNESS.   IN NO EVENT SHALL DIGITAL EQUIPMENT
  32. ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
  33. ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
  34. ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
  35. ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
  36. ;* SOFTWARE.
  37.  
  38. ; $Id: runtime-methods.scm,v 1.25 1992/09/19 06:54:56 birkholz Exp $
  39.  
  40. ;;;; Methods used in the Dylan environment
  41.  
  42. ;;; Methods (not generically dispatched)
  43.  
  44. ;; dylan::function->method has been moved to support.scm -- it takes in
  45. ;; a scheme function and converts it to a Dylan-callable procedure by
  46. ;; ignoring the multiple-values and next-method arguments that come from Dylan.
  47.  
  48. (define dylan:+
  49.   (dylan::function->method
  50.    only-rest-args
  51.    (lambda rest-args
  52.      (if (null? rest-args)
  53.      0
  54.      (let loop ((rest (cdr rest-args))
  55.             (sum (car rest-args)))
  56.        (if (null? rest)
  57.            sum
  58.            (loop (cdr rest)
  59.              (dylan-call dylan:binary+ sum (car rest)))))))))
  60.  
  61. (define dylan:*
  62.   (dylan::function->method
  63.    only-rest-args
  64.    (lambda rest-args
  65.      (if (null? rest-args)
  66.      1
  67.      (let loop ((rest (cdr rest-args))
  68.             (sum (car rest-args)))
  69.        (if (null? rest)
  70.            sum
  71.            (loop (cdr rest)
  72.              (dylan-call dylan:binary* sum (car rest)))))))))
  73.  
  74. (define dylan:-
  75.   (dylan::function->method
  76.    at-least-one-number
  77.    (lambda (num . rest-num)
  78.      (if (null? rest-num)
  79.      (- num)
  80.      (let loop ((rest rest-num)
  81.             (sum num))
  82.        (if (null? rest)
  83.            sum
  84.            (loop (cdr rest)
  85.              (dylan-call dylan:binary- sum (car rest)))))))))
  86.  
  87. (define dylan:/
  88.   (dylan::function->method
  89.    at-least-one-number
  90.    (lambda (num . rest-num)
  91.      (if (null? rest-num)
  92.      (/ num)
  93.      (let loop ((rest rest-num)
  94.             (sum num))
  95.        (if (null? rest)
  96.            sum
  97.            (loop (cdr rest)
  98.              (dylan-call dylan:binary/ sum (car rest)))))))))
  99.  
  100. (define dylan:identity (dylan::function->method one-object (lambda (x) x)))
  101.  
  102. (define dylan:=
  103.   (dylan::function->method
  104.    at-least-two-objects
  105.    (lambda (obj1 obj2 . rest-objs)
  106.      (if (dylan-call dylan:binary= obj1 obj2)
  107.      (let loop ((rest-objs rest-objs))
  108.        (if (null? rest-objs)
  109.            #T
  110.            (if (dylan-call dylan:binary= obj1 (car rest-objs))
  111.            (loop (cdr rest-objs))
  112.            #F)))
  113.      #F))))
  114.  
  115. (define dylan:/=
  116.   (dylan::function->method
  117.    two-objects
  118.    (lambda (obj1 obj2) (not (dylan-call dylan:binary= obj1 obj2)))))
  119.  
  120. (define dylan:<
  121.   (dylan::function->method
  122.    at-least-two-objects
  123.    (lambda (obj1 obj2 . rest-objs)
  124.      (if (dylan-call dylan:binary< obj1 obj2)
  125.      (let loop ((rest-objs rest-objs)
  126.             (prev-obj obj2))
  127.        (if (null? rest-objs)
  128.            #T
  129.            (if (dylan-call dylan:binary< prev-obj (car rest-objs))
  130.            (loop (cdr rest-objs) (car rest-objs))
  131.            #F)))
  132.      #F))))
  133.  
  134. (define dylan:>=
  135.   (dylan::function->method
  136.    at-least-two-objects
  137.    (lambda (obj1 obj2 . rest-objs)
  138.      (if (not (dylan-call dylan:binary< obj1 obj2))
  139.      (let loop ((rest-objs rest-objs)
  140.             (prev-obj obj2))
  141.        (if (null? rest-objs)
  142.            #T
  143.            (if (not (dylan-call dylan:binary< prev-obj (car rest-objs)))
  144.            (loop (cdr rest-objs) (car rest-objs))
  145.            #F)))
  146.      #F))))
  147.  
  148. (define dylan:>
  149.   (dylan::function->method
  150.    at-least-two-objects
  151.    (lambda (obj1 obj2 . rest-objs)
  152.      (if (not (or (dylan-call dylan:binary< obj1 obj2)
  153.           (dylan-call dylan:binary= obj1 obj2)))
  154.      (let loop ((rest-objs rest-objs)
  155.             (prev-obj obj2))
  156.        (if (null? rest-objs)
  157.            #T
  158.            (if (not (or (dylan-call dylan:binary< prev-obj (car rest-objs))
  159.                 (dylan-call dylan:binary=
  160.                     prev-obj (car rest-objs))))
  161.            (loop (cdr rest-objs) (car rest-objs))
  162.            #F)))
  163.      #F))))
  164.  
  165. (define dylan:<=
  166.   (dylan::function->method
  167.    at-least-two-objects
  168.    (lambda (obj1 obj2 . rest-objs)
  169.      (if (or (dylan-call dylan:binary< obj1 obj2)
  170.          (dylan-call dylan:binary= obj1 obj2))
  171.      (let loop ((rest-objs rest-objs)
  172.             (prev-obj obj2))
  173.        (if (null? rest-objs)
  174.            #T
  175.            (if (or (dylan-call dylan:binary< prev-obj (car rest-objs))
  176.                (dylan-call dylan:binary= prev-obj (car rest-objs)))
  177.            (loop (cdr rest-objs) (car rest-objs))
  178.            #F)))
  179.      #F))))
  180.  
  181. (define dylan:always
  182.   (dylan::function->method
  183.    one-object
  184.    (lambda (obj)
  185.      (lambda args
  186.        args                ; Ignored
  187.        obj))))
  188.  
  189. (define dylan:id?
  190.   (dylan::function->method
  191.    at-least-two-objects
  192.    (lambda (obj1 . others)
  193.      (let loop ((rest others))
  194.        (or (null? rest)
  195.        (and (eq? obj1 (car rest))
  196.         (loop (cdr rest))))))))
  197.  
  198.  
  199. (define dylan:min
  200.   (dylan::function->method
  201.    at-least-one-real
  202.    (lambda (real1 . others)
  203.      (let loop ((rest others)
  204.         (min-so-far real1))
  205.        (if (null? rest)
  206.        min-so-far
  207.        (loop (cdr rest)
  208.          (if (dylan-call dylan:binary< real1 (car rest))
  209.              real1
  210.              (car rest))))))))
  211.  
  212. (define dylan:max
  213.   (dylan::function->method
  214.    at-least-one-real
  215.    (lambda (real1 . others)
  216.      (let loop ((rest others)
  217.         (max-so-far real1))
  218.        (if (null? rest)
  219.        max-so-far
  220.        (loop (cdr rest)
  221.          (if (not (dylan-call dylan:binary< real1 (car rest)))
  222.              real1
  223.              (car rest))))))))
  224.  
  225.  
  226. (define (reduce l fn init-value)
  227.   (if (null? l)
  228.       init-value
  229.       (reduce (cdr l) fn (fn (car l) init-value))))
  230.  
  231. (define dylan:lcm
  232.   (dylan::function->method
  233.    only-rest-args
  234.    (lambda args
  235.      (reduce args (lambda (x) (dylan-call dylan:binary-lcm x)) 1))))
  236.  
  237. (define dylan:gcd
  238.   (dylan::function->method
  239.    only-rest-args
  240.    (lambda args
  241.      (reduce args (lambda (x) (dylan-call dylan:binary-gcd x)) 0))))
  242.  
  243. ;;; Special functions
  244.  
  245. (define (dylan:values multiple-values? next-method . values)
  246.   next-method                ; Ignore
  247.   (if (not multiple-values?)
  248.       (if (null? values) #F (car values))
  249.       (let ((last-loc (- (vector-length multiple-values?) 1)))
  250.     (do ((index 0 (+ index 1))
  251.          (rest values (cdr rest)))
  252.         ((or (null? rest) (= index last-loc))
  253.          (vector-set! multiple-values? last-loc rest)
  254.          multiple-values?)        ; Return vector itself. See BIND
  255.       (vector-set! multiple-values? index (car rest))))))
  256.  
  257. (define dylan:not (make-dylan-callable not 1))
  258.  
  259. ;;; Generic functions
  260.  
  261. (define (dylan::generic-fn name param-list scheme-operation)
  262.   ;; Scheme-Operation can be #F, meaning "no methods initially available"
  263.   (let ((generic-function
  264.      (dylan::create-generic-function
  265.       name
  266.       (param-list.nrequired param-list)
  267.       (param-list.keys param-list)
  268.       (param-list.rest? param-list))))
  269.     (if scheme-operation
  270.     (add-method generic-function
  271.             (dylan::function->method param-list scheme-operation)))
  272.     generic-function))
  273.  
  274. (define (dylan::make-<object> class . rest)
  275.   (define (gather-from-slots slot-fn)
  276.     (let loop ((keywords '())
  277.            (keys (map slot-fn (vector->list (class.slots class)))))
  278.       (if (null? keys)
  279.       keywords
  280.       (loop (if (car keys) (cons (car keys) keywords) keywords)
  281.         (cdr keys)))))
  282.   (dylan::keyword-validate #F rest #T)
  283.   (let ((instance-data (make-vector
  284.             (class.instance-data-size class)))
  285.     (slots (class.slots class)))
  286.     (let ((required (gather-from-slots slot.required-init-keyword)))
  287.       (for-each
  288.        (lambda (k)
  289.      (dylan::find-keyword
  290.       rest k (lambda ()
  291.            (dylan-call dylan:error
  292.                    "make -- missing required keyword" k rest))))
  293.        required)
  294.       (vector-iterate slots
  295.               (lambda (i slot)
  296.             i        ; unused
  297.             (initialize-slot! slot rest instance-data '(INSTANCE))))
  298.       (let ((result (make-instance class #F instance-data)))
  299.     (add-to-population! (class.instances class) result)
  300.     (dylan-apply dylan:initialize result rest)
  301.     result))))
  302.  
  303. (define dylan:make
  304.   (dylan::generic-fn 'make
  305.    (make-param-list `((CLASS ,<class>)) #F #F #T)
  306.    dylan::make-<object>))
  307.  
  308. (define dylan:initialize
  309.   (dylan::generic-fn 'initialize
  310.     (make-param-list `((OBJECT ,<object>)) #F #F #T)
  311.     (lambda (instance . rest) rest instance)))
  312.  
  313. (define dylan:slot-initialized?
  314.   (dylan::generic-fn 'slot-initialized?
  315.    (make-param-list `((INSTANCE ,<object>) (GETTER ,<generic-function>))
  316.             #F #F #F)
  317.    (lambda (instance getter)
  318.      (let* ((class (instance.class instance))
  319.         (slots (class.slots class))
  320.         (the-slot (same-slot-getter-in-slot-vector->slot getter slots)))
  321.        (if (not the-slot)
  322.        (dylan-call dylan:error
  323.                "slot-initialized? -- no such slot"
  324.                instance getter class))
  325.        (not
  326.     (eq? *the-uninitialized-slot-value*
  327.          (case (slot.allocation the-slot)
  328.            ((VIRTUAL CONSTANT) 'initialized)
  329.            ((CLASS) (let ((data-loc (slot.data-location the-slot)))
  330.               (vector-ref (class.class-data (car data-loc))
  331.                       (cdr data-loc))))
  332.         ((EACH-SUBCLASS) (vector-ref (class.class-data class)
  333.                          (slot.data-location the-slot)))
  334.         ((INSTANCE) (vector-ref (instance.data instance)
  335.                     (slot.data-location the-slot)))
  336.         (else (dylan-call dylan:error
  337.                   "slot-initialized? -- bad allocation"
  338.                   (slot.allocation the-slot)
  339.                   instance getter class)))))))))
  340.  
  341. ;;; Arithmetic
  342.  
  343. (define dylan:odd? (dylan::generic-fn 'odd? one-integer odd?))
  344. (define dylan:even? (dylan::generic-fn 'even? one-integer even?))
  345. (define dylan:zero? (dylan::generic-fn 'zero? one-number zero?))
  346. (define dylan:positive? (dylan::generic-fn 'positive? one-number positive?))
  347. (define dylan:negative? (dylan::generic-fn 'negative? one-real negative?))
  348. (define dylan:integral? (dylan::generic-fn 'integral? one-number integer?))
  349.  
  350. (define dylan:abs (dylan::generic-fn 'abs one-number abs))
  351. (define dylan:sin (dylan::generic-fn 'sin one-number sin))
  352. (define dylan:cos (dylan::generic-fn 'cos one-number cos))
  353. (define dylan:tan (dylan::generic-fn 'tan one-number tan))
  354. (define dylan:asin (dylan::generic-fn 'asin one-number asin))
  355. (define dylan:acos (dylan::generic-fn 'acos one-number acos))
  356. (define dylan:atan (dylan::generic-fn 'atan one-number atan))
  357. (define dylan:atan2 (dylan::generic-fn 'atan2 two-numbers atan))
  358. (define dylan:exp (dylan::generic-fn 'exp one-number exp))
  359. (define dylan:log (dylan::generic-fn 'log one-number log))
  360. (define dylan:expt (dylan::generic-fn 'expt one-number expt))
  361. (define dylan:sqrt (dylan::generic-fn 'sqrt one-number sqrt))
  362.  
  363. (define dylan:modulo
  364.   (dylan::generic-fn 'modulo two-reals
  365.     (lambda (r1 r2)
  366.       (let* ((multiple-values (vector #F #F '()))
  367.          (floor (dylan-mv-call dylan:floor/ multiple-values r1 r2)))
  368.     floor                ; Ignored
  369.     (vector-ref multiple-values 0)))))
  370.  
  371. (define dylan:remainder
  372.   (dylan::generic-fn 'remainder
  373.    two-reals
  374.    (lambda (real1 real2)
  375.      (- real1 (* real2 (truncate (/ real1 real2)))))))
  376.  
  377. (define dylan:unary- (dylan::generic-fn 'unary- one-number -))
  378. (define dylan:unary/ (dylan::generic-fn 'unary/ one-number /))
  379.  
  380. (define dylan:binary+ (dylan::generic-fn 'binary+ two-numbers +))
  381. (define dylan:binary* (dylan::generic-fn 'binary* two-numbers *))
  382. (define dylan:binary- (dylan::generic-fn 'binary- two-numbers -))
  383. (define dylan:binary/ (dylan::generic-fn 'binary/ two-numbers /))
  384.  
  385. ;;; Class stuff
  386.  
  387. (define dylan:all-superclasses
  388.   (dylan::generic-fn 'all-superclasses
  389.    one-class
  390.    (lambda (class)
  391.      (map-over-all-superclasses! class (lambda x x)))))
  392.  
  393. (define dylan:direct-superclasses
  394.   (dylan::generic-fn 'direct-superclasses one-class class.superclasses))
  395.  
  396. (define dylan:direct-subclasses
  397.   (dylan::generic-fn 'direct-subclasses one-class
  398.     (lambda (class)
  399.       (population->list (class.subclasses class)))))
  400.  
  401.  
  402. (define dylan:instance?
  403.   (dylan::generic-fn 'instance?
  404.    (make-param-list `((OBJECT ,<object>) (CLASS ,<class>)) #F #F #F)
  405.    (lambda (obj class)
  406.      (subclass? (get-type obj) class))))
  407.  
  408. (define dylan:subclass?
  409.   (dylan::generic-fn 'subclass?
  410.    (make-param-list `((CLASS-1 ,<class>) (CLASS-2 ,<class>)) #F #F #F)
  411.    subclass?))
  412.  
  413. (define dylan:object-class
  414.   (dylan::generic-fn 'object-class one-object get-type))
  415.  
  416. (define dylan:slot-descriptors
  417.   (dylan::generic-fn 'slot-descriptors one-class class.slots))
  418.  
  419. (define dylan:slot-getter
  420.   (dylan::generic-fn 'slot-getter one-slot slot.getter))
  421. (define dylan:slot-setter
  422.   (dylan::generic-fn 'slot-setter one-slot slot.setter))
  423. (define dylan:slot-type
  424.   (dylan::generic-fn 'slot-type one-slot slot.type))
  425. (define dylan:slot-allocation
  426.   (dylan::generic-fn 'slot-allocation one-slot slot.allocation))
  427.  
  428. (define dylan:binary< (dylan::generic-fn 'binary< two-numbers <))
  429.  
  430. (define dylan:binary=
  431.   ;; Use eq? if object not same class.
  432.   (dylan::generic-fn 'binary= two-objects eq?))
  433.  
  434. (add-method dylan:binary= (dylan::function->method two-numbers =))
  435.  
  436.  
  437. (define dylan:as-lowercase
  438.   ;; Takes <character>s or <string>s.
  439.   (dylan::generic-fn 'as-lowercase one-object #F))
  440.  
  441. (add-method
  442.  dylan:as-lowercase
  443.  (dylan::function->method
  444.   one-char
  445.   (lambda (char) (char-downcase char))))
  446.  
  447. (define dylan:as-uppercase
  448.   ;; Takes <character>s or <string>s.
  449.   (dylan::generic-fn 'as-uppercase one-object #F))
  450.  
  451. (add-method
  452.  dylan:as-uppercase
  453.  (dylan::function->method
  454.   one-char
  455.   (lambda (char) (char-upcase char))))
  456.  
  457.  
  458. (define dylan:=hash (dylan::generic-fn '=hash one-integer (lambda (x) x)))
  459.  
  460. (add-method dylan:=hash            ; ***** TEMP: for debugging tables
  461.   (dylan::function->method
  462.    one-real
  463.    (lambda (real)
  464.      (dylan-call dylan:as <integer> (dylan-call dylan:floor real)))))
  465.  
  466. (define dylan:floor (dylan::generic-fn 'floor one-real #F))
  467.  
  468. (add-method
  469.  dylan:floor
  470.  (dylan::dylan-callable->method
  471.   one-real
  472.   (lambda (multiple-values next-method num)
  473.     next-method
  474.     (dylan-mv-call dylan:values multiple-values
  475.            (floor num) (- num (floor num))))))
  476.  
  477. (define dylan:ceiling (dylan::generic-fn 'ceiling one-real #F))
  478.  
  479. (add-method
  480.  dylan:ceiling
  481.  (dylan::dylan-callable->method
  482.   one-real
  483.   (lambda (multiple-values next-method num)
  484.     next-method
  485.     (dylan-mv-call dylan:values multiple-values
  486.            (ceiling num) (- num (ceiling num))))))
  487.  
  488. (define dylan:truncate (dylan::generic-fn 'truncate one-real #F))
  489.  
  490. (add-method
  491.  dylan:truncate
  492.  (dylan::dylan-callable->method
  493.   one-real
  494.   (lambda (multiple-values next-method num)
  495.     next-method
  496.     (dylan-mv-call dylan:values multiple-values
  497.            (truncate num) (- num (truncate num))))))
  498.  
  499. (define dylan:round (dylan::generic-fn 'round one-real #F))
  500.  
  501. (add-method
  502.  dylan:round
  503.  (dylan::dylan-callable->method
  504.   one-real
  505.   (lambda (multiple-values next-method num)
  506.     next-method
  507.     (dylan-mv-call dylan:values multiple-values
  508.            (round num) (- num (round num))))))
  509.  
  510. (define dylan:floor/ (dylan::generic-fn 'floor/ two-reals #F))
  511.  
  512. (add-method
  513.  dylan:floor/
  514.  (dylan::dylan-callable->method
  515.   two-reals
  516.   (lambda (multiple-values next-method real1 real2)
  517.     next-method
  518.     (let ((floor-div-result (floor (/ real1 real2))))
  519.       (dylan-mv-call dylan:values multiple-values
  520.              floor-div-result
  521.              (- real1 (* real2 floor-div-result)))))))
  522.  
  523. (define dylan:ceiling/ (dylan::generic-fn 'ceiling/ two-reals #F))
  524.  
  525. (add-method
  526.  dylan:ceiling/
  527.  (dylan::dylan-callable->method
  528.   two-reals
  529.   (lambda (multiple-values next-method real1 real2)
  530.     next-method
  531.     (let ((ceiling-div-result (ceiling (/ real1 real2))))
  532.       (dylan-mv-call dylan:values multiple-values
  533.              ceiling-div-result
  534.              (- real1 (* real2 ceiling-div-result)))))))
  535.  
  536. (define dylan:truncate/ (dylan::generic-fn 'truncate/ two-reals #F))
  537.  
  538. (add-method
  539.  dylan:truncate/
  540.  (dylan::dylan-callable->method
  541.   two-reals
  542.   (lambda (multiple-values next-method real1 real2)
  543.     next-method
  544.     (let ((truncate-div-result (truncate (/ real1 real2))))
  545.       (dylan-mv-call dylan:values multiple-values
  546.              truncate-div-result
  547.              (- real1 (* real2 truncate-div-result)))))))
  548.  
  549. (define dylan:round/ (dylan::generic-fn 'round/ two-reals #F))
  550.  
  551. (add-method
  552.  dylan:round/
  553.  (dylan::dylan-callable->method
  554.   two-reals
  555.   (lambda (multiple-values next-method real1 real2)
  556.     next-method
  557.     (let ((round-div-result (round (/ real1 real2))))
  558.       (dylan-mv-call dylan:values multiple-values
  559.              round-div-result
  560.              (- real1 (* real2 round-div-result)))))))
  561.  
  562. (define dylan:add-method
  563.   (let* ((params
  564.       (make-param-list
  565.        `((GENERIC-FUNCTION ,<generic-function>) (METHOD ,<method>))
  566.        #F #F #F))
  567.      (generic-function (dylan::generic-fn 'add-method params #F)))
  568.     (add-method
  569.      generic-function
  570.      (dylan::make-method
  571.       params
  572.       (lambda (multiple-values next-method generic-function method)
  573.     next-method            ; Ignored
  574.     (add-method generic-function method
  575.             (lambda (new old)
  576.               (dylan-mv-call dylan:values multiple-values new old))))))
  577.     generic-function))
  578.  
  579. (define dylan:shallow-copy
  580.   (dylan::generic-fn 'shallow-copy
  581.    one-object
  582.    (lambda (obj)
  583.      (dylan-call dylan:error
  584.          "shallow-copy -- not specialized for this object type" obj))))
  585.  
  586. (define dylan:binary-gcd
  587.   (dylan::generic-fn 'binary-gcd two-integers gcd))
  588. (define dylan:binary-lcm
  589.   (dylan::generic-fn 'binary-lcm two-integers lcm))
  590.  
  591. (define dylan:denominator
  592.   (dylan::generic-fn 'denominator one-real denominator))
  593. (define dylan:numerator
  594.   (dylan::generic-fn 'numerator one-real numerator))
  595.  
  596. (define dylan:angle
  597.   (dylan::generic-fn 'angle one-number angle))
  598. (define dylan:magnitude
  599.   (dylan::generic-fn 'magnitude one-number magnitude))
  600. (define dylan:imag-part
  601.   (dylan::generic-fn 'imag-part one-number imag-part))
  602. (define dylan:real-part
  603.   (dylan::generic-fn 'real-part one-number real-part))
  604. (define dylan:rationalize
  605.   (dylan::generic-fn 'rationalize one-number rationalize))
  606.  
  607. (define dylan:init-function
  608.   (dylan::generic-fn 'init-function one-slot slot.init-function))
  609.  
  610. (define dylan:init-keyword
  611.   (dylan::generic-fn 'init-keyword one-slot slot.init-keyword))
  612.  
  613. (define dylan:init-value
  614.   (dylan::generic-fn 'init-value one-slot #F))
  615.  
  616. (add-method
  617.  dylan:init-value
  618.  (dylan::dylan-callable->method
  619.   one-slot
  620.   (lambda (multiple-values next-method slot)
  621.     next-method
  622.     (if (slot.has-initial-value? slot)
  623.     (dylan-mv-call dylan:values multiple-values
  624.                (slot.init-value slot) #T)
  625.     (dylan-mv-call dylan:values multiple-values #F #F)))))
  626.  
  627. (define dylan:applicable-method?
  628.   (dylan::generic-fn 'applicable-method?
  629.     (make-param-list `((FN ,<function>)) #F #T #F)
  630.     (lambda (fn . args)
  631.       (cond
  632.        ((dylan::generic-function? fn)
  633.     (any? (lambda (method)
  634.         (method-applicable? method args))
  635.           (generic-function.methods fn)))
  636.        ((dylan::method? fn)
  637.     (method-applicable? fn args))
  638.        (else #F)))))
  639.  
  640. (define dylan:apply
  641.   (dylan::generic-fn 'apply (make-param-list `((FN ,<function>)) #F #T #F) #F))
  642.  
  643. (add-method
  644.  dylan:apply
  645.  (dylan::dylan-callable->method
  646.   (make-param-list `((FN ,<function>)) #F #T #F)
  647.   (lambda (multiple-values next-method fn . args)
  648.     (dylan-full-apply fn multiple-values next-method
  649.               (split-last
  650.                args
  651.                (lambda (early end)
  652.              (append early
  653.                  (if (null? end)
  654.                      '()
  655.                      (iterate->list (lambda (x) x)
  656.                             (car end))))))))))
  657.  
  658. (define dylan:as
  659.   (dylan::generic-fn 'as
  660.     (make-param-list `((CLASS ,<class>) (OBJECT ,<object>)) #F #F #F)
  661.     (lambda (class obj)
  662.       (if (dylan-call dylan:instance? obj class)
  663.       obj
  664.       (dylan-call dylan:error
  665.               "as -- not specialized for this class type"
  666.               class obj)))))
  667. (begin
  668.   ;; integer <-> character
  669.   (add-method dylan:as
  670.     (dylan::function->method
  671.      (make-param-list `((CLASS ,(dylan::make-singleton <integer>))
  672.             (OBJECT ,<character>)) #F #F #F)
  673.      (lambda (class object) class (char->integer object))))
  674.   (add-method dylan:as
  675.     (dylan::function->method
  676.      (make-param-list `((CLASS ,(dylan::make-singleton <character>))
  677.             (OBJECT ,<integer>)) #F #F #F)
  678.      (lambda (class object) class (integer->char object))))
  679.   ;; number conversions
  680.   (define (no-change class object) class object)
  681.   (define (->exact class object) class (inexact->exact object))
  682.   (define (->inexact class object) class (exact->inexact object))
  683.   (add-method dylan:as
  684.     (dylan::function->method
  685.      (make-param-list `((CLASS ,(dylan::make-singleton <number>))
  686.             (OBJECT ,<number>)) #F #F #F)
  687.      no-change))
  688.   (add-method dylan:as
  689.     (dylan::function->method
  690.      (make-param-list `((CLASS ,(dylan::make-singleton <complex>))
  691.             (OBJECT ,<number>)) #F #F #F)
  692.      no-change))
  693.   (add-method dylan:as
  694.     (dylan::function->method
  695.      (make-param-list `((CLASS ,(dylan::make-singleton <real>))
  696.             (OBJECT ,<real>)) #F #F #F)
  697.      no-change))
  698.   (add-method dylan:as
  699.     (dylan::function->method
  700.      (make-param-list `((CLASS ,(dylan::make-singleton <rectangular-complex>))
  701.             (OBJECT ,<number>)) #F #F #F)
  702.      no-change))
  703.   (add-method dylan:as
  704.     (dylan::function->method
  705.      (make-param-list `((CLASS ,(dylan::make-singleton <rational>))
  706.             (OBJECT ,<number>)) #F #F #F)
  707.      ->exact))
  708.   (add-method dylan:as
  709.     (dylan::function->method
  710.      (make-param-list `((CLASS ,(dylan::make-singleton <float>))
  711.             (OBJECT ,<number>)) #F #F #F)
  712.      ->inexact))
  713.   (add-method dylan:as
  714.     (dylan::function->method
  715.      (make-param-list `((CLASS ,(dylan::make-singleton <integer>))
  716.             (OBJECT ,<number>)) #F #F #F)
  717.      ->exact))
  718.   (add-method dylan:as
  719.     (dylan::function->method
  720.      (make-param-list `((CLASS ,(dylan::make-singleton <ratio>))
  721.             (OBJECT ,<number>)) #F #F #F)
  722.      ->exact))
  723.   (add-method dylan:as
  724.     (dylan::function->method
  725.      (make-param-list `((CLASS ,(dylan::make-singleton <single-float>))
  726.             (OBJECT ,<number>)) #F #F #F)
  727.      ->inexact))
  728.   (add-method dylan:as
  729.     (dylan::function->method
  730.      (make-param-list `((CLASS ,(dylan::make-singleton <double-float>))
  731.             (OBJECT ,<number>)) #F #F #F)
  732.      ->inexact))
  733.   (add-method dylan:as
  734.     (dylan::function->method
  735.      (make-param-list `((CLASS ,(dylan::make-singleton <extended-float>))
  736.             (OBJECT ,<number>)) #F #F #F)
  737.      ->inexact))
  738.   ; symbols, strings, and keywords
  739.   (add-method dylan:as
  740.     (dylan::function->method
  741.      (make-param-list `((CLASS ,(dylan::make-singleton <string>))
  742.             (SYMBOL ,<symbol>)) #F #F #F)
  743.      (lambda (class symbol)
  744.        class                ; Unused
  745.        (symbol->string symbol))))
  746.   (add-method dylan:as
  747.     (dylan::function->method
  748.      (make-param-list `((CLASS ,(dylan::make-singleton <string>))
  749.             (KEYWORD ,<keyword>)) #F #F #F)
  750.      (lambda (class keyword)
  751.        class                ; Unused
  752.        (let ((string (symbol->string keyword)))
  753.      (substring string 0 (- (string-length string) 1))))))
  754.   (add-method dylan:as
  755.     (dylan::function->method
  756.      (make-param-list `((CLASS ,(dylan::make-singleton <symbol>))
  757.             (STRING ,<string>)) #F #F #F)
  758.      (lambda (class string)
  759.        class                ; Unused
  760.        (new-name "" string ""))))
  761.   (add-method dylan:as
  762.     (dylan::function->method
  763.      (make-param-list `((CLASS ,(dylan::make-singleton <keyword>))
  764.             (STRING ,<string>)) #F #F #F)
  765.      (lambda (class string)
  766.        class                ; Unused
  767.        (new-name "" string ":"))))
  768.   )
  769.  
  770. (define dylan:complement
  771.   (dylan::function->method
  772.     one-function
  773.     (lambda (fn)
  774.       (make-dylan-callable
  775.        (lambda args
  776.      (not (dylan-apply fn args)))))))
  777.  
  778. (define dylan:compose
  779.   (dylan::function->method
  780.    at-least-one-function
  781.    (lambda (fn . rest-fns)
  782.      (if (null? rest-fns)
  783.      fn
  784.      (lambda (multiple-values next-method . args)
  785.        (define (compose fn rest-fns)
  786.          (if (null? rest-fns)
  787.          (dylan-apply fn args)
  788.          (dylan-call fn (compose (car rest-fns) (cdr rest-fns)))))
  789.        next-method            ; Not used
  790.        (dylan-mv-call fn multiple-values
  791.               (compose (car rest-fns) (cdr rest-fns))))))))
  792.  
  793. (define dylan:disjoin
  794.   (dylan::function->method
  795.    at-least-one-function
  796.    (lambda (fn . rest-fns)
  797.      (if (null? rest-fns)
  798.      fn
  799.      (lambda (multiple-values next-method . args)
  800.        next-method
  801.        (let loop ((fn fn)
  802.               (rest-fns rest-fns))
  803.          (if (null? rest-fns)
  804.          (dylan-mv-apply fn multiple-values args)
  805.          (let ((value (dylan-apply fn args)))
  806.            (if value
  807.                value
  808.                (loop (car rest-fns) (cdr rest-fns)))))))))))
  809.  
  810. (define dylan:conjoin
  811.   (dylan::function->method
  812.    at-least-one-function
  813.    (lambda (fn . rest-fns)
  814.      (if (null? rest-fns)
  815.      fn
  816.      (lambda (multiple-values next-method . args)
  817.        next-method
  818.        (let loop ((fn fn)
  819.               (rest-fns rest-fns))
  820.          (if (null? rest-fns)
  821.          (dylan-mv-apply fn multiple-values args)
  822.          (if (dylan-apply fn args)
  823.              (loop (car rest-fns) (cdr rest-fns))
  824.              #F))))))))
  825.  
  826. (define dylan:curry
  827.   (dylan::function->method
  828.    function-and-arguments
  829.    (lambda (fn . curried-args)
  830.      (lambda (multiple-values next-method . args)
  831.        next-method
  832.        (dylan-mv-apply fn multiple-values (append curried-args args))))))
  833.  
  834. (define dylan:rcurry
  835.  (dylan::function->method
  836.   function-and-arguments
  837.   (lambda (fn . curried-args)
  838.     (lambda (multiple-values next-method . args)
  839.       next-method
  840.       (dylan-mv-apply fn multiple-values (append args curried-args))))))
  841.